home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / quadlap.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  18KB  |  623 lines
  1. ;;                -[Thu Mar  1 10:54:27 1990 by jkf]-
  2. ;; pcl to quad translation
  3. ;; $Header: quadlap.cl,v 1.1 90/02/21 08:54:42 jkf Exp Locker: jkf $
  4. ;;
  5. ;; copyright (c) 1990 Franz Inc.
  6. ;;
  7. (in-package :compiler)
  8.  
  9.  
  10.  
  11.  
  12. (defvar *arg-to-treg* nil)
  13. (defvar *cvar-to-index* nil)
  14. (defvar *reg-array* nil)
  15. (defvar *closure-treg* nil)
  16. (defvar *nargs-treg* nil)
  17.  
  18. (defvar *debug-sparc* nil)
  19.  
  20. (defmacro pcl-make-lambda (&key required)
  21.   `(list 'lambda nil :unknown-type 0 compiler::.function-level. 
  22.     ,required nil nil nil nil nil nil nil nil nil 
  23.     nil 'compiler::none nil nil nil 
  24.     nil nil nil nil nil nil 0 nil))
  25.  
  26. (defmacro pcl-make-varrec (&key name loc contour-level)
  27.   `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level))
  28.  
  29. (defmacro pcl-make-lap (&key lap constants cframe-size locals)
  30.   `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil))
  31.  
  32.  
  33. (defstruct (preg)
  34.   ;; pseudo reg descritpor
  35.   treg        ; associated treg
  36.   index     ; :index if this is an index type reg
  37.           ; :vector if this is a vector type reg
  38.   )
  39.  
  40.  
  41. (defun pcl::excl-lap-closure-generator (closure-vars-names
  42.                    arg-names
  43.                    index-regs
  44.                    vector-regs
  45.                    fixnum-vector-regs
  46.                    t-regs
  47.                    lap-code)
  48.   (let ((function (pcl::excl-lap-closure-gen closure-vars-names
  49.                    arg-names
  50.                    index-regs
  51.                    (append vector-regs fixnum-vector-regs)
  52.                    t-regs
  53.                    lap-code)))
  54.     #'(lambda (&rest closure-vals)
  55.     (insert-closure-vals function closure-vals))))
  56.  
  57.  
  58. (defun pcl::excl-lap-closure-gen
  59.     (closure-vars-names arg-names index-regs vector-regs t-regs lap-code)
  60.   (let ((*quads* nil)
  61.     (*treg-num* 0)
  62.     (*all-tregs* nil)
  63.     (*bb-count* 0)
  64.     *treg-bv-size*
  65.     *treg-vector*
  66.     (*next-catch-frame* 0)
  67.     (*max-catch-frame* -1)
  68.     *catch-labels*
  69.     *top-label*
  70.     *mv-treg*
  71.     *mv-treg-target*
  72.     *zero-treg*
  73.     *nil-treg*
  74.     *bbs* *bb* lap
  75.     ;; bbs
  76.     *cross-block-regs*
  77.     *const-tregs* *move-tregs*
  78.     *actuals*
  79.     *ignore-argcount*
  80.     *binds-specs*
  81.     *bvl-current-bv* ; for bitvector cacher
  82.     *bvl-used-bvs*
  83.     *bvl-index*
  84.     (*inhibit-call-count* t)
  85.     
  86.     ; this fcn
  87.     *arg-to-treg*
  88.     *cvar-to-index* 
  89.     *reg-array*
  90.     minargs
  91.     maxargs
  92.     *closure-treg*
  93.  
  94.     node
  95.     otherargregs
  96.     
  97.     *nargs-treg*
  98.     )
  99.  
  100.     (if* *debug-sparc* 
  101.        then (format t ">>** << Generating sparc lap code~%"))
  102.     
  103.     (setq *nil-treg* 
  104.       #+allegro-v4.0 (new-reg :global t)
  105.       #-allegro-v4.0 (new-reg)
  106.       *mv-treg* (new-reg)
  107.       *mv-treg-target* (list *mv-treg*)
  108.       *zero-treg* (comp::new-reg))
  109.     
  110.     ; examine given args
  111.     
  112.     (setq minargs 0  maxargs 0)
  113.     (let (requireds)
  114.       (dolist (arg arg-names)
  115.     (if* (eq '&rest arg)
  116.        then (setq maxargs nil)
  117.        else (if* (null arg)
  118.            then ; we want a name even though we won't use it
  119.             (setq arg (gensym)))
  120.         (incf minargs)
  121.         (incf maxargs)
  122.         (push (cons arg (new-reg)) *arg-to-treg*)
  123.         (push (pcl-make-varrec :name arg 
  124.                    :loc (cdr (car *arg-to-treg*))
  125.                    :contour-level 0)
  126.               requireds)
  127.         ))
  128.       (setq node (pcl-make-lambda :required  (nreverse requireds))))
  129.     (setq *arg-to-treg* (nreverse *arg-to-treg*))
  130.     
  131.     ; build closure vector list
  132.     (let ((index -1))
  133.       (dolist (cvar closure-vars-names)
  134.     (push (cons cvar (incf index)) *cvar-to-index*)))
  135.     
  136.     (let ((maxreg (max (apply #'max (cons -1 index-regs))
  137.                (apply #'max (cons -1 vector-regs))
  138.                (apply #'max (cons -1 t-regs)))))
  139.       (setq *reg-array* (make-array (1+ maxreg))))
  140.     
  141.     (dolist (index index-regs)
  142.       (setf (svref *reg-array* index)
  143.     (make-preg :treg (new-reg)
  144.            :index :index)))
  145.     
  146.     (dolist (vector vector-regs)
  147.       (setf (svref *reg-array* vector) 
  148.     (make-preg :treg (new-reg)
  149.            :index :vector)))
  150.     
  151.     (dolist (tr t-regs)
  152.       (setf (svref *reg-array* tr) (make-preg :treg (new-reg))))
  153.     
  154.  
  155.     (if* closure-vars-names
  156.        then (setq *closure-treg* (new-reg)))
  157.     (setq *nargs-treg* (new-reg))
  158.         
  159.     ;; (md-allocate-global-tregs)
  160.     
  161.     ; function entry
  162.     (qe nop :arg :first-block)
  163.     (qe entry)
  164.     (qe argcount :arg (list minargs maxargs))
  165.     (qe lambda :d (mapcar #'cdr *arg-to-treg*))
  166.     (qe register :arg :nargs :d (list *nargs-treg*))
  167.  
  168.     (if* *closure-treg*
  169.        then ; put the first closure vector in *closure-treg*
  170.         (qe extract-closure-vec :d (list *closure-treg*))
  171.         (let ((offsetreg (new-reg)))
  172.           (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg))
  173.           (qe ref :u (list *closure-treg* offsetreg) 
  174.           :d (list *closure-treg*)
  175.           :arg :long))
  176.         )
  177.  
  178.     (excl-gen-quads lap-code)
  179.  
  180.     (if* *debug-sparc*
  181.        then (do-quad-list (quad next *quads*)
  182.           (format t "~a~%" quad))
  183.  
  184.         (format t "basic blocks~%"))
  185.     
  186.     (setq *bbs* (qc-compute-basic-blocks *quads*))
  187.     
  188.     (excl::target-class-case
  189.      ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*))))
  190.     
  191.     (qc-live-variable-analysis *bbs*)
  192.     
  193.     (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16)))
  194.       
  195.     (qc-build-treg-vector)
  196.     
  197.  
  198.     (let ((*dump-bbs* nil)
  199.       (r::*local-regs*
  200.        ; use the in registers that aren't in use
  201.        (append r::*local-regs*
  202.            (if* maxargs
  203.               then (nthcdr maxargs r::*in-regs* )))))
  204.       (unwind-protect
  205.       (progn
  206.         ; machine specific code generation
  207.         (multiple-value-bind (lap-code literals size-struct locals)
  208.         #+(target-class r m e)
  209.         (progn
  210.           #+allegro-v4.0 
  211.           (md-codegen node *bbs*
  212.                   nil otherargregs)
  213.           #-allegro-v4.0 
  214.           (md-codegen node *bbs*
  215.                   *nil-treg* *mv-treg* *zero-treg*
  216.                   nil otherargregs))
  217.           
  218.         #-(target-class r m e) (md-codegen node *bbs*)
  219.         (setq lap
  220.           (pcl-make-lap :lap lap-code
  221.                 :constants literals
  222.                 :cframe-size size-struct
  223.                 :locals  locals)))
  224.  
  225.          
  226.         lap)
  227.     (giveback-bvs)))
  228.     
  229.     #+ignore 
  230.     (progn (format t "sparc code pre optimization~%")
  231.        (dolist (instr (lap-lap lap))
  232.          (format t "> ~a~%" instr)))
  233.     (md-optimize lap) ; peephole optimize
  234.     (if* *debug-sparc*
  235.        then (format t "sparc code post optimization~%")
  236.         (dolist (instr (lap-lap lap))
  237.           (format t "> ~a~%" instr)))
  238.     (md-assemble lap)
  239.     (setq last-lap lap)
  240.  
  241.     (nl-runtime-make-a-fcnobj lap)))
  242.  
  243. (defun qe-slot-access (operand offset dest)
  244.   ;; access a slot in a structure
  245.   (let ((temp (new-reg)))
  246.     (qe const :arg offset :d (list temp))
  247.     (qe ref :u (list (get-treg-of operand) temp) 
  248.     :d (list (get-treg-of dest))
  249.     :arg :long)))
  250.  
  251.  
  252. (defun get-treg-of (operand &optional res-operand)
  253.   ;; get the appropriate treg for the operand
  254.   (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand))))
  255.     (if* (numberp operand)
  256.        then (let ((treg (new-reg)))
  257.           (qe const :arg operand :d (list treg))
  258.           treg)
  259.      elseif (consp operand)
  260.        then (ecase (car operand)
  261.           (:reg 
  262.            (preg-treg (svref *reg-array* (cadr operand))))
  263.           (:arg 
  264.            (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
  265.          (if* (null x)
  266.             then (error "where is arg ~s" operand)
  267.             else x)))
  268.           (:cvar
  269.            (let ((res-treg (or prefer-treg (new-reg)))
  270.              (temp-treg (new-reg)))
  271.          (qe const :arg (+ (mdparam 'md-svector-data0-adj)
  272.                    (* 4 (cdr (assoc (cadr operand)
  273.                             *cvar-to-index*
  274.                             :test #'eq))))
  275.              :d (list temp-treg))
  276.          (qe ref :u (list *closure-treg* temp-treg)
  277.              :d (list res-treg)
  278.              :arg :long)
  279.          res-treg))
  280.           (:constant
  281.            (let ((treg (or prefer-treg (new-reg))))
  282.          (qe const :arg (if* (fixnump (cadr operand))
  283.                    then (* 8 (cadr operand)) ; md!!
  284.                    else (cadr operand))
  285.              :d (list treg))
  286.          treg))
  287.           (:index-constant
  288.            ; operand invented by jkf to denote an index type constant
  289.            (let ((treg (or prefer-treg (new-reg))))
  290.          (qe const :arg (if* (fixnump (cadr operand))
  291.                    then (* 4 (cadr operand)) ; md!!
  292.                    else (cadr operand))
  293.              :d (list treg))
  294.          treg)))
  295.        else (error "bad operand: ~s" operand)